home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / MacQForth 1.0 / source / MacQForth Source / Monitor.mops < prev    next >
Text File  |  1995-04-03  |  13KB  |  360 lines
  1. \ Section: System Monitor
  2.  
  3. \
  4. \ System monitor - $FFF0
  5. \
  6.  
  7. \ alternate output words capture text in theText buffer
  8.  
  9. variable {len}  \ hold the address and length for {expect}
  10. variable {addr}
  11. variable {ptr}
  12. variable ?cr
  13.  
  14. : {emit}  ( c -- ) rA ! $F3    ; \ emit a character through $F3
  15. : {space} ( -- )   20 {emit}  ; \ output a space
  16. : {cr}    ( -- )   ?scroll cr ; \ cr 
  17.  
  18. : {expect} ( addr len -- ) \ get a line of text
  19.   \ using $FB for 'key' and $F3 for 'emit'
  20.    {len} !  {addr} !  0 {ptr} !  0 ?cr !
  21.    begin
  22.      {ptr} @  {len} @ <  \ while ptr<len and not ?cr
  23.      ?cr @ not and
  24.    while
  25.      $FB \ key           \ read a key
  26.      rA @ 8d <> if     
  27.        rA @ 88 <> if
  28.          $F3 \ emit       
  29.          rA @ 7F and {addr} @ {ptr} @ + c! 
  30.          {ptr} @ 1+ {ptr} ! \ not cr or bs, output and put in buffer
  31.        else
  32.          <del   \ remove the character
  33.          {ptr} @ 1- dup 
  34.          0< if drop 0 @xy swap drop E swap gotoxy then  \ bs
  35.          {ptr} !
  36.        then
  37.      else
  38.        0 {addr} @ {ptr} @ + c!   \ cr
  39.        space                     \ remove '_'
  40.        -1 ?cr ! {cr}
  41.      then
  42.    repeat 
  43. ;
  44.  
  45. variable buff
  46.  
  47. variable mnemonics 'type ADC  mnemonics ! \ table of instruction names
  48. 'type AND  , 'type ASL  , 'type BCC  , 'type BCS  , 'type BEQ  , 
  49. 'type BIT  , 'type BMI  , 'type BNE  , 'type BPL  , 'type BRA  , 
  50. 'type BRK  , 'type BVC  , 'type BVS  , 'type CLC  , 'type CLD  , 
  51. 'type CLI  , 'type CLV  , 'type CMP  , 'type CPX  , 'type CPY  , 
  52. 'type DEA  , 'type DEC  , 'type DEX  , 'type DEY  , 'type EOR  , 
  53. 'type INA  , 'type INC  , 'type INX  , 'type INY  , 'type JMP  , 
  54. 'type JSR  , 'type LDA  , 'type LDX  , 'type LDY  , 'type LSR  , 
  55. 'type NOP  , 'type ORA  , 'type PHA  , 'type PHP  , 'type PHX  , 
  56. 'type PHY  , 'type PLA  , 'type PLP  , 'type PLX  , 'type PLY  , 
  57. 'type ROL  , 'type ROR  , 'type RTI  , 'type RTS  , 'type SBC  , 
  58. 'type SEC  , 'type SED  , 'type SEI  , 'type STA  , 'type STX  , 
  59. 'type STY  , 'type STZ  , 'type TAX  , 'type TAY  , 'type TRB  , 
  60. 'type TSB  , 'type TSX  , 'type TXA  , 'type TXS  , 'type TYA  , 
  61. 'type ???  ,
  62.  
  63. \ listing table, each entry is 4 bytes long <00><00><instruction#><mode>
  64.  
  65. \ <mode>=  00 - implied,    1 byte
  66. \          01 - immediate,  2 byte
  67. \          02 - absolute,   3 byte
  68. \          03 - zero page,  2 byte
  69. \          04 - ABS,rX,      3 byte
  70. \          05 - ZPG,rX,      2 byte
  71. \          06 - (IND,rX),    2 byte
  72. \          07 - ABS(IND,rX), 3 byte
  73. \          08 - (IND),rY,    2 byte
  74. \          09 - (ZPG),      2 byte
  75. \          0A - (ABS),      3 byte
  76. \          0B - ABS,rY,      3 byte
  77. \          0C - ZPG,rY,      2 byte
  78.  
  79.  
  80. variable list  0C00 list !
  81. 2606 , 4300 , 4300 , 3E03 , 2603 , 0303 , 4300 , 2800 , 2601 , 0300 ,
  82. 4300 , 3E02 , 2602 , 0302 , 4300 ,        \ row 00
  83.  
  84. 0A01 , 2608 , 2609 , 4300 , 3D03 , 2606 , 0306 , 4300 , 0F00 , 260B ,
  85. 1B00 , 4300 , 3D02 , 2604 , 0304 , 4300 , \ row 01
  86.  
  87. 2002 , 0206 , 4300 , 4300 , 0703 , 0203 , 2F03 , 4300 , 2C00 , 0201 ,
  88. 2F00 , 4300 , 0702 , 0202 , 2F02 , 4300 , \ row 02
  89.  
  90. 0801 , 0208 , 0209 , 4300 , 0705 , 0205 , 2F05 , 4300 , 3400 , 020B ,
  91. 1600 , 4300 , 0704 , 0204 , 2F04 , 4300 , \ row 03
  92.  
  93. 3100 , 1A06 , 4300 , 4300 , 4300 , 1A03 , 2403 , 4300 , 2700 , 1A01 ,
  94. 2400 , 4300 , 1F02 , 1A02 , 2402 , 4300 , \ row 04
  95.  
  96. 0D01 , 1A08 , 1A09 , 4300 , 4300 , 1A05 , 2405 , 4300 , 1100 , 1A0B ,
  97. 2A00 , 4300 , 4300 , 1A04 , 2404 , 4300 , \ row 05
  98.  
  99. 3200 , 0106 , 4300 , 4300 , 3A03 , 0103 , 3003 , 4300 , 2B00 , 0101 ,
  100. 3000 , 4300 , 1F0A , 0102 , 3002 , 4300 , \ row 06
  101.  
  102. 0E01 , 0106 , 0109 , 4300 , 3A05 , 0105 , 3005 , 4300 , 3600 , 010B ,
  103. 2E00 , 4300 , 1F07 , 0104 , 3004 , 4300 , \ row 07
  104.  
  105. 0B01 , 3706 , 4300 , 4300 , 3903 , 3703 , 3803 , 4300 , 1900 , 0701 ,
  106. 4000 , 4300 , 3902 , 3702 , 3802 , 4300 , \ row 08
  107.  
  108. 0401 , 3708 , 3709 , 4300 , 3905 , 3705 , 380C , 4300 , 4200 , 370B ,
  109. 4100 , 4300 , 3A02 , 3704 , 3A04 , 4300 , \ row 09
  110.  
  111. 2301 , 2106 , 2201 , 4300 , 2303 , 2103 , 2203 , 4300 , 3C00 , 2101 ,
  112. 3B00 , 4300 , 2302 , 2102 , 2202 , 4300 , \ row 0A
  113.  
  114. 0501 , 2108 , 2109 , 4300 , 2305 , 2105 , 220C , 4300 , 1200 , 210B ,
  115. 3F00 , 4300 , 2304 , 2104 , 220B , 4300 , \ row 0B
  116.  
  117. 1501 , 1306 , 4300 , 4300 , 1503 , 1303 , 1703 , 4300 , 1E00 , 1301 ,
  118. 1800 , 4300 , 1502 , 1302 , 1702 , 4300 , \ row 0C
  119.  
  120. 0901 , 1308 , 1309 , 4300 , 4300 , 1305 , 1705 , 4300 , 1000 , 130B ,
  121. 2900 , 4300 , 4300 , 1304 , 1704 , 4300 , \ row 0D
  122.  
  123. 1401 , 3306 , 4300 , 4300 , 1403 , 3303 , 1C03 , 4300 , 1D00 , 3301 ,
  124. 2500 , 4300 , 1402 , 3302 , 1C02 , 4300 , \ row 0E
  125.  
  126. 0601 , 3308 , 3309 , 4300 , 4300 , 3305 , 1C05 , 4300 , 3500 , 330B ,
  127. 2D00 , 4300 , 4300 , 3304 , 1C04 , 4300 , \ row 0F 
  128.  
  129. : uppercase \ make a character uppercase
  130.    dup dup 60 > swap 7B < and if 20 - then ;
  131.  
  132. : chrs ( buff maxlen -- length ) \ returns the length of the line
  133.    0 do dup i + c@ 0= if drop i FF else 1 then +loop ;
  134.  
  135. variable buff2 4C allot \ temporary buffer   
  136. variable k  \ index
  137. : killSpaces \ remove spaces from the input line
  138.    0 k !
  139.    buff @ 50 chrs 1+ 0 do
  140.      buff @ i + c@ dup 20 <> if
  141.        uppercase buff2 k @ + c!  \ save in temporary buffer
  142.        k @ 1+ k !      \ increment k
  143.      else drop then
  144.    loop
  145.    buff2 50 chrs 1+ 0 do
  146.      buff2 i + c@  buff @ i + c!  \ put in original buffer
  147.    loop ; 
  148.  
  149. variable num 4C allot \ conversion buffer
  150. variable endchar \ stop character
  151. variable buffaddr \ buffer address
  152. : getNumber ( addr end-char -- n ) \ make a string a number
  153.    1 k ! \ use k defined above in killSpaces
  154.    20 num c! \ initial blank
  155.    endchar ! buffaddr ! \ save end character and buffer address
  156.    begin
  157.      buffaddr @ c@ endchar @ <>  \ haven't reached match character
  158.    while
  159.      buffaddr @ c@ uppercase
  160.      num k @ + c!                \ copy character to num
  161.      buffaddr @ 1+ buffaddr !     \ increment buffer pointer
  162.      k @ 1+ k !                    \ and index pointer
  163.    repeat
  164.    20 num k @ + c!  \ add final blank
  165.     0 num k @ 1+ + c! \ and null
  166.    num k @ 1+ evaluate \ convert and leave on stack, Mops
  167.    \ 0 0 num (number) drop drop \ Yerk
  168. ;    
  169.  
  170. variable lines    \ number of lines listed
  171. variable listAddr \ address
  172. variable aLabel    \ holds a compressed label
  173.  
  174. : printLabel   \ print an instruction label
  175.   1- 4* mnemonics + @ \ get the label 
  176.   aLabel !             \ save it
  177.   aLabel c@ {emit} aLabel 1+ c@ {emit} aLabel 2+ c@ {emit} \ print it
  178.   {space} ;
  179.  
  180. : instSize  \ return instruction size in bytes
  181.     dup 0 = if drop 1 else \ implied
  182.     dup 1 = if drop 2 else \ immediate
  183.     dup 2 = if drop 3 else \ absolute
  184.     dup 3 = if drop 2 else \ zero page
  185.     dup 4 = if drop 3 else \ abs,x
  186.     dup 5 = if drop 2 else \ zpg,x
  187.     dup 6 = if drop 2 else \ ind,x
  188.     dup 7 = if drop 3 else \ abs(ind,x)
  189.     dup 8 = if drop 2 else \ (ind),y
  190.     dup 9 = if drop 2 else \ (zpg)
  191.     dup 0A = if drop 3 else \ (abs)
  192.     dup 0B = if drop 3 else \ abs,y
  193.         0C = if      2 else \ zpg,y
  194.     1 then then then then then then then then then then then then then 
  195. ;
  196.  
  197. : 1hex ( h -- ) \ print a single hex digit
  198.    dup 9 > if 37 + {emit} else 30 + {emit} then ;
  199.  
  200. : 2hex  dup 10 / swap 10 mod swap 1hex 1hex ;
  201. : 4hex  dup 100 / swap 100 mod swap 2hex 2hex ;
  202.  
  203. : .$ ( num size -- ) \ print num as a size hex number
  204.    \ assumes size is either 2 or 4
  205.    2 = if 2hex else 4hex then ;
  206.    
  207. : outHex ( size -- ) \ output hex data
  208.    listAddr @ $@ 2 .$ {space}  \ all are at least one byte
  209.    dup 1 = if drop {space} {space} {space}  {space} {space} else
  210.    dup 2 = if  drop          \ two bytes
  211.      listAddr @ 1+ $@ 2 .$
  212.      {space} {space} {space}
  213.    else
  214.      3 = if                  \ three bytes
  215.      listAddr @ 1+ $@ 2 .$ {space}
  216.      listAddr @ 2+ $@ 2 .$
  217.      then
  218.    then then
  219.    {space} ;
  220.  
  221. variable b1 \ first data byte
  222. variable b2 \ second data byte   
  223.  
  224. : .b @ 2 .$ ; \ print a data byte
  225.  
  226. : .imm 23 {emit} 24 {emit} b1 .b ;                               \ immediate
  227. : .abs 24 {emit} b2 .b b1 .b   ;                                 \ absolute
  228. : .zpg 24 {emit} b1 .b         ;                                 \ zero page
  229. : .abx 24 {emit} b2 .b b1 .b 2C {emit} 58 {emit} ;               \ absolute,x
  230. : .zpx 24 {emit} b1 .b 2C {emit} 58 {emit} ;                     \ zero page,x
  231. : .zix 28 {emit} 24 {emit} b1 .b 2C {emit} 58 {emit} 29 {emit} ; \ ($33,rX)
  232. : .aix 28 {emit} 24 {emit} b2 .b b1 .b 2C {emit} 58 {emit} 29 {emit} ; \ ($FDED,rX)
  233. : .ziy 28 {emit} 24 {emit} b1 .b 29 {emit} 2C {emit} 59 {emit} ; \ ($33),rY
  234. : .zpi 28 {emit} 24 {emit} b1 .b 29 {emit} ;                     \ ($33)
  235. : .abi 28 {emit} 24 {emit} b2 .b b1 .b 29 {emit} ;               \ ($FDED)
  236. : .aby 24 {emit} b2 .b b1 .b 2C {emit} 59 {emit} ;               \ $FDED,rY
  237. : .zpy 24 {emit} b1 .b 2C {emit} 59 {emit} ;                     \ $33,rY
  238.  
  239. : printMode ( mode -- ) \ output instruction data
  240.    listAddr @ 1+ $@ b1 !  listAddr @ 2+ $@ b2 ! \ save data bytes
  241.    dup 0 = if drop      else \ implied
  242.    dup 1 = if drop .imm else \ immediate
  243.    dup 2 = if drop .abs else \ absolute
  244.    dup 3 = if drop .zpg else \ zero page
  245.    dup 4 = if drop .abx else \ absolute,x
  246.    dup 5 = if drop .zpx else \ zero page,x
  247.    dup 6 = if drop .zix else \ zero page indirect x
  248.    dup 7 = if drop .aix else \ absolute indirect x
  249.    dup 8 = if drop .ziy else \ zero page indirect y
  250.    dup 9 = if drop .zpi else \ zero page indirect
  251.    dup rA = if drop .abi else \ absolute indirect
  252.    dup B = if drop .aby else \ absolute y
  253.        C = if drop .zpy else \ zero page y
  254.    then then then then then then then then then then then 
  255.    then then
  256. ;
  257.  
  258. : listMem                                       \ 'L' - list memory
  259.    buff @ 1+ c@ 0 <> if
  260.      buff @ 1+ 0 getNumber  listAddr !
  261.    then
  262.    0 lines !
  263.    begin 
  264.      lines @ 16 <
  265.    while
  266.      listAddr @ 4 .$ 2D {emit} {space} \ print address
  267.      listAddr @ $@ 4* list + 3+ c@      \ get mode
  268.      instSize outHex                     \ print hex codes
  269.      listAddr @ $@ 4* list + 2+ c@        \ get instruction
  270.      printLabel                            \ print instruction mnemonic
  271.      listAddr @ $@ 4* list + 3+ c@          \ get mode
  272.      dup printMode {space} {cr}              \ print data
  273.      instSize listAddr @ + listAddr !         \ next instruction
  274.      lines @ 1+ lines !                        \ increment lines
  275.    repeat
  276. ;
  277.  
  278. variable addr1 \ starting address
  279. variable addr2 \ ending address
  280. : dumpHex                                       \ 'rX' - examine range of memory
  281.    buff @ 1+ 2E getNumber addr1 !     \ start
  282.    buffAddr @ 1+ 0 getNumber addr2 ! \ end, buffaddr pts to '.' from above
  283.    addr1 @ 4 .$ 2D {emit} {space}
  284.    addr2 @ 1+ addr1 @ do
  285.       i $@ 2 .$ {space}
  286.       i addr1 @ - 1+ 8 mod 0= if 
  287.          {space} {cr} 
  288.          i 1+ 4 .$ 2D {emit} {space}
  289.       then
  290.    loop {space} {cr}
  291. ;
  292.  
  293. : altMem                                        \ 'rS' - change memory
  294.    buff @ 1+ 0 getNumber addr1 ! \ starting address
  295.    addr1 @ 4 .$ 2D {emit} {space} addr1 @ $@ 2 .$ {space}
  296.    begin
  297.      addr2 3 {expect}  \ get input
  298.      addr2 c@ 21 <>  \ input not a '!'
  299.    while
  300.      addr2 c@ 0 <> if   \ not a return
  301.        addr2 0 getNumber \ get number entered
  302.        addr1 @ $!         \ save the new value
  303.      then
  304.      addr1 @ 1+ addr1 !     \ go to next byte
  305.      addr1 @ 4 .$ 2D {emit} {space}
  306.      addr1 @ $@ 2 .$ {space}
  307.    repeat ;
  308.  
  309. : interpretLine  \ interpret the line in the input buffer
  310.    buff @ c@ \ get first character
  311.    dup 58 = if drop dumpHex 0 else \ 'rX' examine memory
  312.    dup 4C = if drop listMem 0 else \ 'L' list memory
  313.    dup 51 = if drop -1        else \ 'Q' quit
  314.    dup 53 = if drop altMem  0 else \ 'rS' substitute memory
  315.    dup  0 = if drop         0 else \ <cr>
  316.        0 \ simply ignore it
  317.    then then then then then
  318. ;
  319.  
  320. variable tempA \ hold the current accumulator value to be restored on exit
  321.  
  322. : $CF  \ a simple monitor program
  323.    \
  324.    \ monitor commands:
  325.    \
  326.    \  L<addr>   -  disassembled listing starting at address
  327.    \  L         -  disassembled listing from last address+1
  328.    \  Q         -  exit monitor and return to Forth
  329.    \  rS<addr>   -  set memory starting at <addr>, ! exits
  330.    \  rX<addr1>.<addr2> - hex dump from <addr1> to <addr2>
  331.    \
  332.    0 0200 rY @ + $!       \ set end-of-line marker, rY-reg holds line length
  333.    killSpaces             \ remove the spaces
  334.    interpretLine          \ interpret the line
  335.    if #Z set else #Z unset then  \ set Z flag to quit
  336. ;
  337.  
  338. : $C3 popQF $0000 10018 + ! ; \ set startup word
  339.  
  340. : $B7  \ low-level decompiler, assumes address on the stack
  341.    popQF  listAddr !
  342.    begin 
  343.      listAddr @ 4 .$ 2D {emit} {space} \ print address
  344.      listAddr @ $@ 4* list + 3+ c@      \ get mode
  345.      instSize outHex                     \ print hex codes
  346.      listAddr @ $@ 4* list + 2+ c@        \ get instruction
  347.      printLabel                            \ print instruction mnemonic
  348.      listAddr @ $@ 4* list + 3+ c@          \ get mode
  349.      dup printMode {space} {cr}              \ print data
  350.      instSize listAddr @ + listAddr !         \ next instruction
  351.    listAddr @ $@ 60 = until
  352.    
  353.    \ output last 'RTS'
  354.    listAddr @ 4 .$ 2D {emit} {space} \ print address
  355.    listAddr @ $@ 4* list + 3+ c@      \ get mode
  356.    instSize outHex                     \ print hex codes
  357.    listAddr @ $@ 4* list + 2+ c@        \ get instruction
  358.    printLabel                            \ print instruction mnemonic
  359.    listAddr @ $@ 4* list + 3+ c@          \ get mode
  360.    printMode {space} {cr}